home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Dpkg / Deps.pm < prev    next >
Encoding:
Perl POD Document  |  2012-09-17  |  30.5 KB  |  1,201 lines
  1. # Copyright ┬⌐ 2007-2009 Rapha├½l Hertzog <hertzog@debian.org>
  2. #
  3. # This program is free software; you may redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. #
  8. # This is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. #
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15. #########################################################################
  16. # Several parts are inspired by lib/Dep.pm from lintian (same license)
  17. #
  18. # Copyright ┬⌐ 1998 Richard Braakman
  19. # Portions Copyright ┬⌐ 1999 Darren Benham
  20. # Portions Copyright ┬⌐ 2000 Sean 'Shaleh' Perry
  21. # Portions Copyright ┬⌐ 2004 Frank Lichtenheld
  22. # Portions Copyright ┬⌐ 2006 Russ Allbery
  23.  
  24. package Dpkg::Deps;
  25.  
  26. =encoding utf8
  27.  
  28. =head1 NAME
  29.  
  30. Dpkg::Deps - parse and manipulate dependencies of Debian packages
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. The Dpkg::Deps module provides objects implementing various types of
  35. dependencies.
  36.  
  37. The most important function is deps_parse(), it turns a dependency line in
  38. a set of Dpkg::Deps::{Simple,AND,OR,Union} objects depending on the case.
  39.  
  40. =head1 FUNCTIONS
  41.  
  42. All the deps_* functions are exported by default.
  43.  
  44. =over 4
  45.  
  46. =cut
  47.  
  48. use strict;
  49. use warnings;
  50.  
  51. our $VERSION = "1.00";
  52.  
  53. use Dpkg::Version;
  54. use Dpkg::Arch qw(get_host_arch);
  55. use Dpkg::ErrorHandling;
  56. use Dpkg::Gettext;
  57.  
  58. use base qw(Exporter);
  59. our @EXPORT = qw(deps_parse deps_eval_implication deps_compare);
  60.  
  61. # Some factorized function
  62.  
  63. # Dpkg::Deps::_arch_is_superset(\@p, \@q)
  64. #
  65. # Returns true if the arch list @p is a superset of arch list @q.
  66. # The arguments can also be undef in case there's no explicit architecture
  67. # restriction.
  68.  
  69. sub _arch_is_superset {
  70.     my ($p, $q) = @_;
  71.     my $p_arch_neg = defined($p) && $p->[0] =~ /^!/;
  72.     my $q_arch_neg = defined($q) && $q->[0] =~ /^!/;
  73.  
  74.     # If "p" has no arches, it is a superset of q and we should fall through
  75.     # to the version check.
  76.     if (not defined $p) {
  77.     return 1;
  78.     }
  79.  
  80.     # If q has no arches, it is a superset of p and there are no useful
  81.     # implications.
  82.     elsif (not defined $q) {
  83.     return 0;
  84.     }
  85.  
  86.     # Both have arches.  If neither are negated, we know nothing useful
  87.     # unless q is a subset of p.
  88.     elsif (not $p_arch_neg and not $q_arch_neg) {
  89.     my %p_arches = map { $_ => 1 } @{$p};
  90.     my $subset = 1;
  91.     for my $arch (@{$q}) {
  92.         $subset = 0 unless $p_arches{$arch};
  93.     }
  94.     return 0 unless $subset;
  95.     }
  96.  
  97.     # If both are negated, we know nothing useful unless p is a subset of
  98.     # q (and therefore has fewer things excluded, and therefore is more
  99.     # general).
  100.     elsif ($p_arch_neg and $q_arch_neg) {
  101.     my %q_arches = map { $_ => 1 } @{$q};
  102.     my $subset = 1;
  103.     for my $arch (@{$p}) {
  104.         $subset = 0 unless $q_arches{$arch};
  105.     }
  106.     return 0 unless $subset;
  107.     }
  108.  
  109.     # If q is negated and p isn't, we'd need to know the full list of
  110.     # arches to know if there's any relationship, so bail.
  111.     elsif (not $p_arch_neg and $q_arch_neg) {
  112.     return 0;
  113.     }
  114.  
  115.     # If p is negated and q isn't, q is a subset of p if none of the
  116.     # negated arches in p are present in q.
  117.     elsif ($p_arch_neg and not $q_arch_neg) {
  118.     my %q_arches = map { $_ => 1 } @{$q};
  119.     my $subset = 1;
  120.     for my $arch (@{$p}) {
  121.         $subset = 0 if $q_arches{substr($arch, 1)};
  122.     }
  123.     return 0 unless $subset;
  124.     }
  125.     return 1;
  126. }
  127.  
  128. =item deps_eval_implication($rel_p, $v_p, $rel_q, $v_q)
  129.  
  130. ($rel_p, $v_p) and ($rel_q, $v_q) express two dependencies as (relation,
  131. version). The relation variable can have the following values that are
  132. exported by Dpkg::Version: REL_EQ, REL_LT, REL_LE, REL_GT, REL_GT.
  133.  
  134. This functions returns 1 if the "p" dependency implies the "q"
  135. dependency. It returns 0 if the "p" dependency implies that "q" is
  136. not satisfied. It returns undef when there's no implication.
  137.  
  138. The $v_p and $v_q parameter should be Dpkg::Version objects.
  139.  
  140. =cut
  141.  
  142. sub deps_eval_implication {
  143.     my ($rel_p, $v_p, $rel_q, $v_q) = @_;
  144.  
  145.     # If versions are not valid, we can't decide of any implication
  146.     return undef unless defined($v_p) and $v_p->is_valid();
  147.     return undef unless defined($v_q) and $v_q->is_valid();
  148.  
  149.     # q wants an exact version, so p must provide that exact version.  p
  150.     # disproves q if q's version is outside the range enforced by p.
  151.     if ($rel_q eq REL_EQ) {
  152.         if ($rel_p eq REL_LT) {
  153.             return ($v_p <= $v_q) ? 0 : undef;
  154.         } elsif ($rel_p eq REL_LE) {
  155.             return ($v_p < $v_q) ? 0 : undef;
  156.         } elsif ($rel_p eq REL_GT) {
  157.             return ($v_p >= $v_q) ? 0 : undef;
  158.         } elsif ($rel_p eq REL_GE) {
  159.             return ($v_p > $v_q) ? 0 : undef;
  160.         } elsif ($rel_p eq REL_EQ) {
  161.             return ($v_p == $v_q);
  162.         }
  163.     }
  164.  
  165.     # A greater than clause may disprove a less than clause. An equal
  166.     # cause might as well.  Otherwise, if
  167.     # p's clause is <<, <=, or =, the version must be <= q's to imply q.
  168.     if ($rel_q eq REL_LE) {
  169.         if ($rel_p eq REL_GT) {
  170.             return ($v_p >= $v_q) ? 0 : undef;
  171.         } elsif ($rel_p eq REL_GE) {
  172.             return ($v_p > $v_q) ? 0 : undef;
  173.     } elsif ($rel_p eq REL_EQ) {
  174.             return ($v_p <= $v_q) ? 1 : 0;
  175.         } else { # <<, <=
  176.             return ($v_p <= $v_q) ? 1 : undef;
  177.         }
  178.     }
  179.  
  180.     # Similar, but << is stronger than <= so p's version must be << q's
  181.     # version if the p relation is <= or =.
  182.     if ($rel_q eq REL_LT) {
  183.         if ($rel_p eq REL_GT or $rel_p eq REL_GE) {
  184.             return ($v_p >= $v_p) ? 0 : undef;
  185.         } elsif ($rel_p eq REL_LT) {
  186.             return ($v_p <= $v_q) ? 1 : undef;
  187.     } elsif ($rel_p eq REL_EQ) {
  188.             return ($v_p < $v_q) ? 1 : 0;
  189.         } else { # <<, <=
  190.             return ($v_p < $v_q) ? 1 : undef;
  191.         }
  192.     }
  193.  
  194.     # Same logic as above, only inverted.
  195.     if ($rel_q eq REL_GE) {
  196.         if ($rel_p eq REL_LT) {
  197.             return ($v_p <= $v_q) ? 0 : undef;
  198.         } elsif ($rel_p eq REL_LE) {
  199.             return ($v_p < $v_q) ? 0 : undef;
  200.     } elsif ($rel_p eq REL_EQ) {
  201.             return ($v_p >= $v_q) ? 1 : 0;
  202.         } else { # >>, >=
  203.             return ($v_p >= $v_q) ? 1 : undef;
  204.         }
  205.     }
  206.     if ($rel_q eq REL_GT) {
  207.         if ($rel_p eq REL_LT or $rel_p eq REL_LE) {
  208.             return ($v_p <= $v_q) ? 0 : undef;
  209.         } elsif ($rel_p eq REL_GT) {
  210.             return ($v_p >= $v_q) ? 1 : undef;
  211.     } elsif ($rel_p eq REL_EQ) {
  212.             return ($v_p > $v_q) ? 1 : 0;
  213.         } else {
  214.             return ($v_p > $v_q) ? 1 : undef;
  215.         }
  216.     }
  217.  
  218.     return undef;
  219. }
  220.  
  221. =item my $dep = deps_parse($line, %options)
  222.  
  223. This function parse the dependency line and returns an object, either a
  224. Dpkg::Deps::AND or a Dpkg::Deps::Union. Various options can alter the
  225. behaviour of that function.
  226.  
  227. =over 4
  228.  
  229. =item use_arch (defaults to 1)
  230.  
  231. Take into account the architecture restriction part of the dependencies.
  232. Set to 0 to completely ignore that information.
  233.  
  234. =item host_arch (defaults to the current architecture)
  235.  
  236. Define the host architecture. Needed only if the reduce_arch option is
  237. set to 1. By default it uses Dpkg::Arch::get_host_arch() to identify
  238. the proper architecture.
  239.  
  240. =item reduce_arch (defaults to 0)
  241.  
  242. If set to 1, ignore dependencies that do not concern the current host
  243. architecture. This implicitely strips off the architecture restriction
  244. list so that the resulting dependencies are directly applicable to the
  245. current architecture.
  246.  
  247. =item union (defaults to 0)
  248.  
  249. If set to 1, returns a Dpkg::Deps::Union instead of a Dpkg::Deps::AND. Use
  250. this when parsing non-dependency fields like Conflicts.
  251.  
  252. =back
  253.  
  254. =cut
  255.  
  256. sub deps_parse {
  257.     my $dep_line = shift;
  258.     my %options = (@_);
  259.     $options{use_arch} = 1 if not exists $options{use_arch};
  260.     $options{reduce_arch} = 0 if not exists $options{reduce_arch};
  261.     $options{host_arch} = get_host_arch() if not exists $options{host_arch};
  262.     $options{union} = 0 if not exists $options{union};
  263.  
  264.     # Strip trailing/leading spaces
  265.     $dep_line =~ s/^\s+//;
  266.     $dep_line =~ s/\s+$//;
  267.  
  268.     my @dep_list;
  269.     foreach my $dep_and (split(/\s*,\s*/m, $dep_line)) {
  270.         my @or_list = ();
  271.         foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) {
  272.         my $dep_simple = Dpkg::Deps::Simple->new($dep_or);
  273.         if (not defined $dep_simple->{package}) {
  274.         warning(_g("can't parse dependency %s"), $dep_or);
  275.         return undef;
  276.         }
  277.         $dep_simple->{arches} = undef if not $options{use_arch};
  278.             if ($options{reduce_arch}) {
  279.         $dep_simple->reduce_arch($options{host_arch});
  280.         next if not $dep_simple->arch_is_concerned($options{host_arch});
  281.         }
  282.         push @or_list, $dep_simple;
  283.         }
  284.     next if not @or_list;
  285.     if (scalar @or_list == 1) {
  286.         push @dep_list, $or_list[0];
  287.     } else {
  288.         my $dep_or = Dpkg::Deps::OR->new();
  289.         $dep_or->add($_) foreach (@or_list);
  290.         push @dep_list, $dep_or;
  291.     }
  292.     }
  293.     my $dep_and;
  294.     if ($options{union}) {
  295.     $dep_and = Dpkg::Deps::Union->new();
  296.     } else {
  297.     $dep_and = Dpkg::Deps::AND->new();
  298.     }
  299.     foreach my $dep (@dep_list) {
  300.         if ($options{union} and not $dep->isa("Dpkg::Deps::Simple")) {
  301.             warning(_g("an union dependency can only contain simple dependencies"));
  302.             return undef;
  303.         }
  304.         $dep_and->add($dep);
  305.     }
  306.     return $dep_and;
  307. }
  308.  
  309. =item deps_compare($a, $b)
  310.  
  311. Implements a comparison operator between two dependency objects.
  312. This function is mainly used to implement the sort() method.
  313.  
  314. =back
  315.  
  316. =cut
  317.  
  318. our %relation_ordering = (
  319.     'undef' => 0,
  320.     REL_GE() => 1,
  321.     REL_GT() => 2,
  322.     REL_EQ() => 3,
  323.     REL_LT() => 4,
  324.     REL_LE() => 5,
  325. );
  326.  
  327. sub deps_compare {
  328.     my ($a, $b) = @_;
  329.     return -1 if $a->is_empty();
  330.     return 1 if $b->is_empty();
  331.     while ($a->isa('Dpkg::Deps::Multiple')) {
  332.     return -1 if $a->is_empty();
  333.     my @deps = $a->get_deps();
  334.     $a = $deps[0];
  335.     }
  336.     while ($b->isa('Dpkg::Deps::Multiple')) {
  337.     return 1 if $b->is_empty();
  338.     my @deps = $b->get_deps();
  339.     $b = $deps[0];
  340.     }
  341.     my $ar = defined($a->{relation}) ? $a->{relation} : "undef";
  342.     my $br = defined($b->{relation}) ? $b->{relation} : "undef";
  343.     return (($a->{package} cmp $b->{package}) ||
  344.         ($relation_ordering{$ar} <=> $relation_ordering{$br}) ||
  345.         ($a->{version} cmp $b->{version}));
  346. }
  347.  
  348.  
  349. package Dpkg::Deps::Simple;
  350.  
  351. =head1 OBJECTS - Dpkg::Deps::*
  352.  
  353. There are several kind of dependencies. A Dpkg::Deps::Simple dependency
  354. represents a single dependency statement (it relates to one package only).
  355. Dpkg::Deps::Multiple dependencies are built on top of this object
  356. and combine several dependencies in a different manners. Dpkg::Deps::AND
  357. represents the logical "AND" between dependencies while Dpkg::Deps::OR
  358. represents the logical "OR". Dpkg::Deps::Multiple objects can contain
  359. Dpkg::Deps::Simple object as well as other Dpkg::Deps::Multiple objects.
  360.  
  361. In practice, the code is only meant to handle the realistic cases which,
  362. given Debian's dependencies structure, imply those restrictions: AND can
  363. contain Simple or OR objects, OR can only contain Simple objects.
  364.  
  365. Dpkg::Deps::KnowFacts is a special object that is used while evaluating
  366. dependencies and while trying to simplify them. It represents a set of
  367. installed packages along with the virtual packages that they might
  368. provide.
  369.  
  370. =head2 Common functions
  371.  
  372. =over 4
  373.  
  374. =item $dep->is_empty()
  375.  
  376. Returns true if the dependency is empty and doesn't contain any useful
  377. information. This is true when a Dpkg::Deps::Simple object has not yet
  378. been initialized or when a (descendant of) Dpkg::Deps::Multiple contains
  379. an empty list of dependencies.
  380.  
  381. =item $dep->get_deps()
  382.  
  383. Return a list of sub-dependencies. For Dpkg::Deps::Simple it returns
  384. itself.
  385.  
  386. =item $dep->output([$fh])
  387.  
  388. =item "$dep"
  389.  
  390. Return a string representing the dependency. If $fh is set, it prints
  391. the string to the filehandle.
  392.  
  393. =item $dep->implies($other_dep)
  394.  
  395. Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies
  396. NOT($other_dep). Returns undef when there's no implication. $dep and
  397. $other_dep do not need to be of the same type.
  398.  
  399. =item $dep->sort()
  400.  
  401. Sort alphabetically the internal list of dependencies. It's a no-op for
  402. Dpkg::Deps::Simple objects.
  403.  
  404. =item $dep->arch_is_concerned($arch)
  405.  
  406. Returns true if the dependency applies to the indicated architecture. For
  407. multiple dependencies, it returns true if at least one of the
  408. sub-dependencies apply to this architecture.
  409.  
  410. =item $dep->reduce_arch($arch)
  411.  
  412. Simplify the dependency to contain only information relevant to the given
  413. architecture. A Dpkg::Deps::Simple object can be left empty after this
  414. operation. For Dpkg::Deps::Multiple objects, the non-relevant
  415. sub-dependencies are simply removed.
  416.  
  417. This trims off the architecture restriction list of Dpkg::Deps::Simple
  418. objects.
  419.  
  420. =item $dep->get_evaluation($facts)
  421.  
  422. Evaluates the dependency given a list of installed packages and a list of
  423. virtual packages provided. Those lists are part of the
  424. Dpkg::Deps::KnownFacts object given as parameters.
  425.  
  426. Returns 1 when it's true, 0 when it's false, undef when some information
  427. is lacking to conclude.
  428.  
  429. =item $dep->simplify_deps($facts, @assumed_deps)
  430.  
  431. Simplify the dependency as much as possible given the list of facts (see
  432. object Dpkg::Deps::KnownFacts) and a list of other dependencies that we
  433. know to be true.
  434.  
  435. =item $dep->has_arch_restriction()
  436.  
  437. For a simple dependency, returns the package name if the dependency
  438. applies only to a subset of architectures.  For multiple dependencies, it
  439. returns the list of package names that have such a restriction.
  440.  
  441. =back
  442.  
  443. =head2 Dpkg::Deps::Simple
  444.  
  445. Such an object has four interesting properties:
  446.  
  447. =over 4
  448.  
  449. =item package
  450.  
  451. The package name (can be undef if the dependency has not been initialized
  452. or if the simplification of the dependency lead to its removal).
  453.  
  454. =item relation
  455.  
  456. The relational operator: "=", "<<", "<=", ">=" or ">>". It can be
  457. undefined if the dependency had no version restriction. In that case the
  458. following field is also undefined.
  459.  
  460. =item version
  461.  
  462. The version.
  463.  
  464. =item arches
  465.  
  466. The list of architectures where this dependency is applicable. It's
  467. undefined when there's no restriction, otherwise it's an
  468. array ref. It can contain an exclusion list, in that case each
  469. architecture is prefixed with an exclamation mark.
  470.  
  471. =back
  472.  
  473. =head3 Methods
  474.  
  475. =over 4
  476.  
  477. =item $simple_dep->parse_string("dpkg-dev (>= 1.14.8) [!hurd-i386]")
  478.  
  479. Parse the dependency and modify internal properties to match the parsed
  480. dependency.
  481.  
  482. =item $simple_dep->merge_union($other_dep)
  483.  
  484. Returns true if $simple_dep could be modified to represent the union of
  485. both dependencies. Otherwise returns false.
  486.  
  487. =back
  488.  
  489. =cut
  490.  
  491. use strict;
  492. use warnings;
  493.  
  494. use Dpkg::Arch qw(debarch_is);
  495. use Dpkg::Version;
  496. use Dpkg::ErrorHandling;
  497. use Dpkg::Gettext;
  498.  
  499. use base qw(Dpkg::Interface::Storable);
  500.  
  501. sub new {
  502.     my ($this, $arg) = @_;
  503.     my $class = ref($this) || $this;
  504.     my $self = {
  505.     'package' => undef,
  506.     'relation' => undef,
  507.     'version' => undef,
  508.     'arches' => undef,
  509.     };
  510.     bless $self, $class;
  511.     $self->parse_string($arg) if defined($arg);
  512.     return $self;
  513. }
  514.  
  515. sub parse {
  516.     my ($self, $fh, $desc) = @_;
  517.     my $line = <$fh>;
  518.     chomp($line);
  519.     return $self->parse_string($line);
  520. }
  521.  
  522. sub parse_string {
  523.     my ($self, $dep) = @_;
  524.     return if not $dep =~
  525.             /^\s*                           # skip leading whitespace
  526.               ([a-zA-Z0-9][a-zA-Z0-9+.-]*)  # package name
  527.               (?:                           # start of optional part
  528.                 \s* \(                      # open parenthesis for version part
  529.                 \s* (<<|<=|=|>=|>>|<|>)     # relation part
  530.                 \s* (.*?)                   # do not attempt to parse version
  531.                 \s* \)                      # closing parenthesis
  532.               )?                            # end of optional part
  533.               (?:                           # start of optional architecture
  534.                 \s* \[                      # open bracket for architecture
  535.                 \s* (.*?)                   # don't parse architectures now
  536.                 \s* \]                      # closing bracket
  537.               )?                            # end of optional architecture
  538.           \s*$                # trailing spaces at end
  539.             /x;
  540.     $self->{package} = $1;
  541.     $self->{relation} = version_normalize_relation($2) if defined($2);
  542.     if (defined($3)) {
  543.         $self->{version} = Dpkg::Version->new($3);
  544.     }
  545.     if (defined($4)) {
  546.     $self->{arches} = [ split(/\s+/, $4) ];
  547.     }
  548. }
  549.  
  550. sub output {
  551.     my ($self, $fh) = @_;
  552.     my $res = $self->{package};
  553.     if (defined($self->{relation})) {
  554.     $res .= " (" . $self->{relation} . " " . $self->{version} .  ")";
  555.     }
  556.     if (defined($self->{'arches'})) {
  557.     $res .= " [" . join(" ", @{$self->{arches}}) . "]";
  558.     }
  559.     if (defined($fh)) {
  560.     print $fh $res;
  561.     }
  562.     return $res;
  563. }
  564.  
  565. # Returns true if the dependency in parameter can deduced from the current
  566. # dependency. Returns false if it can be negated. Returns undef if nothing
  567. # can be concluded.
  568. sub implies {
  569.     my ($self, $o) = @_;
  570.     if ($o->isa('Dpkg::Deps::Simple')) {
  571.     # An implication is only possible on the same package
  572.     return undef if $self->{package} ne $o->{package};
  573.  
  574.     # Our architecture set must be a superset of the architectures for
  575.     # o, otherwise we can't conclude anything.
  576.     return undef unless Dpkg::Deps::_arch_is_superset($self->{arches}, $o->{arches});
  577.  
  578.     # If o has no version clause, then our dependency is stronger
  579.     return 1 if not defined $o->{relation};
  580.     # If o has a version clause, we must also have one, otherwise there
  581.     # can't be an implication
  582.     return undef if not defined $self->{relation};
  583.  
  584.     return Dpkg::Deps::deps_eval_implication($self->{relation},
  585.         $self->{version}, $o->{relation}, $o->{version});
  586.  
  587.     } elsif ($o->isa('Dpkg::Deps::AND')) {
  588.     # TRUE: Need to imply all individual elements
  589.     # FALSE: Need to NOT imply at least one individual element
  590.     my $res = 1;
  591.     foreach my $dep ($o->get_deps()) {
  592.         my $implication = $self->implies($dep);
  593.         unless (defined($implication) && $implication == 1) {
  594.         $res = $implication;
  595.         last if defined $res;
  596.         }
  597.     }
  598.     return $res;
  599.     } elsif ($o->isa('Dpkg::Deps::OR')) {
  600.     # TRUE: Need to imply at least one individual element
  601.     # FALSE: Need to not apply all individual elements
  602.     # UNDEF: The rest
  603.     my $res = undef;
  604.     foreach my $dep ($o->get_deps()) {
  605.         my $implication = $self->implies($dep);
  606.         if (defined($implication)) {
  607.         if (not defined $res) {
  608.             $res = $implication;
  609.         } else {
  610.             if ($implication) {
  611.             $res = 1;
  612.             } else {
  613.             $res = 0;
  614.             }
  615.         }
  616.         last if defined($res) && $res == 1;
  617.         }
  618.     }
  619.     return $res;
  620.     } else {
  621.     internerr("Dpkg::Deps::Simple can't evaluate implication with a %s!",
  622.               ref($o));
  623.     }
  624. }
  625.  
  626. sub get_deps {
  627.     my $self = shift;
  628.     return $self;
  629. }
  630.  
  631. sub sort {
  632.     # Nothing to sort
  633. }
  634.  
  635. sub arch_is_concerned {
  636.     my ($self, $host_arch) = @_;
  637.  
  638.     return 0 if not defined $self->{package}; # Empty dep
  639.     return 1 if not defined $self->{arches};  # Dep without arch spec
  640.  
  641.     my $seen_arch = 0;
  642.     foreach my $arch (@{$self->{arches}}) {
  643.     $arch=lc($arch);
  644.  
  645.     if ($arch =~ /^!/) {
  646.         my $not_arch = $arch;
  647.         $not_arch =~ s/^!//;
  648.  
  649.         if (debarch_is($host_arch, $not_arch)) {
  650.         $seen_arch = 0;
  651.         last;
  652.         } else {
  653.         # !arch includes by default all other arches
  654.         # unless they also appear in a !otherarch
  655.         $seen_arch = 1;
  656.         }
  657.     } elsif (debarch_is($host_arch, $arch)) {
  658.         $seen_arch = 1;
  659.         last;
  660.     }
  661.     }
  662.     return $seen_arch;
  663. }
  664.  
  665. sub reduce_arch {
  666.     my ($self, $host_arch) = @_;
  667.     if (not $self->arch_is_concerned($host_arch)) {
  668.     $self->{package} = undef;
  669.     $self->{relation} = undef;
  670.     $self->{version} = undef;
  671.     $self->{arches} = undef;
  672.     } else {
  673.     $self->{arches} = undef;
  674.     }
  675. }
  676.  
  677. sub has_arch_restriction {
  678.     my ($self) = @_;
  679.     if (defined $self->{arches}) {
  680.     return $self->{package};
  681.     } else {
  682.     return ();
  683.     }
  684. }
  685.  
  686. sub get_evaluation {
  687.     my ($self, $facts) = @_;
  688.     return undef if not defined $self->{package};
  689.     my ($check, $param) = $facts->check_package($self->{package});
  690.     if ($check) {
  691.     if (defined $self->{relation}) {
  692.         if (ref($param)) {
  693.         # Provided packages
  694.         # XXX: Once support for versioned provides is in place,
  695.         # this part must be adapted
  696.         return 0;
  697.         } else {
  698.         if (defined($param)) {
  699.             if (version_compare_relation($param, $self->{relation},
  700.                          $self->{version})) {
  701.             return 1;
  702.             } else {
  703.             return 0;
  704.             }
  705.         } else {
  706.             return undef;
  707.         }
  708.         }
  709.     } else {
  710.         return 1;
  711.     }
  712.     }
  713.     return 0;
  714. }
  715.  
  716. sub simplify_deps {
  717.     my ($self, $facts) = @_;
  718.     my $eval = $self->get_evaluation($facts);
  719.     if (defined($eval) and $eval == 1) {
  720.     $self->{package} = undef;
  721.     $self->{relation} = undef;
  722.     $self->{version} = undef;
  723.     $self->{arches} = undef;
  724.     }
  725. }
  726.  
  727. sub is_empty {
  728.     my $self = shift;
  729.     return not defined $self->{package};
  730. }
  731.  
  732. sub merge_union {
  733.     my ($self, $o) = @_;
  734.     return 0 if not $o->isa('Dpkg::Deps::Simple');
  735.     return 0 if $self->is_empty() or $o->is_empty();
  736.     return 0 if $self->{package} ne $o->{package};
  737.     return 0 if defined $self->{arches} or defined $o->{arches};
  738.  
  739.     if (not defined $o->{relation} and defined $self->{relation}) {
  740.     # Union is the non-versioned dependency
  741.     $self->{relation} = undef;
  742.     $self->{version} = undef;
  743.     return 1;
  744.     }
  745.  
  746.     my $implication = $self->implies($o);
  747.     my $rev_implication = $o->implies($self);
  748.     if (defined($implication)) {
  749.     if ($implication) {
  750.         $self->{relation} = $o->{relation};
  751.         $self->{version} = $o->{version};
  752.         return 1;
  753.     } else {
  754.         return 0;
  755.     }
  756.     }
  757.     if (defined($rev_implication)) {
  758.     if ($rev_implication) {
  759.         # Already merged...
  760.         return 1;
  761.     } else {
  762.         return 0;
  763.     }
  764.     }
  765.     return 0;
  766. }
  767.  
  768. package Dpkg::Deps::Multiple;
  769.  
  770. =head2 Dpkg::Deps::Multiple
  771.  
  772. This the base class for Dpkg::Deps::{AND,OR,Union}. It contains the
  773.  
  774. =over 4
  775.  
  776. =item $mul->add($dep)
  777.  
  778. Add a new dependency object at the end of the list.
  779.  
  780. =back
  781.  
  782. =cut
  783.  
  784. use strict;
  785. use warnings;
  786.  
  787. use Dpkg::ErrorHandling;
  788.  
  789. use base qw(Dpkg::Interface::Storable);
  790.  
  791. sub new {
  792.     my $this = shift;
  793.     my $class = ref($this) || $this;
  794.     my $self = { 'list' => [ @_ ] };
  795.     bless $self, $class;
  796.     return $self;
  797. }
  798.  
  799. sub add {
  800.     my $self = shift;
  801.     push @{$self->{list}}, @_;
  802. }
  803.  
  804. sub get_deps {
  805.     my $self = shift;
  806.     return grep { not $_->is_empty() } @{$self->{list}};
  807. }
  808.  
  809. sub sort {
  810.     my $self = shift;
  811.     my @res = ();
  812.     @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}};
  813.     $self->{list} = [ @res ];
  814. }
  815.  
  816. sub arch_is_concerned {
  817.     my ($self, $host_arch) = @_;
  818.     my $res = 0;
  819.     foreach my $dep (@{$self->{list}}) {
  820.     $res = 1 if $dep->arch_is_concerned($host_arch);
  821.     }
  822.     return $res;
  823. }
  824.  
  825. sub reduce_arch {
  826.     my ($self, $host_arch) = @_;
  827.     my @new;
  828.     foreach my $dep (@{$self->{list}}) {
  829.     $dep->reduce_arch($host_arch);
  830.     push @new, $dep if $dep->arch_is_concerned($host_arch);
  831.     }
  832.     $self->{list} = [ @new ];
  833. }
  834.  
  835. sub has_arch_restriction {
  836.     my ($self) = @_;
  837.     my @res;
  838.     foreach my $dep (@{$self->{list}}) {
  839.     push @res, $dep->has_arch_restriction();
  840.     }
  841.     return @res;
  842. }
  843.  
  844.  
  845. sub is_empty {
  846.     my $self = shift;
  847.     return scalar @{$self->{list}} == 0;
  848. }
  849.  
  850. sub merge_union {
  851.     internerr("The method merge_union() is only valid for Dpkg::Deps::Simple");
  852. }
  853.  
  854. package Dpkg::Deps::AND;
  855.  
  856. =head2 Dpkg::Deps::AND
  857.  
  858. This object represents a list of dependencies who must be met at the same
  859. time.
  860.  
  861. =over 4
  862.  
  863. =item $and->output([$fh])
  864.  
  865. The output method uses ", " to join the list of sub-dependencies.
  866.  
  867. =back
  868.  
  869. =cut
  870.  
  871. use strict;
  872. use warnings;
  873.  
  874. use base qw(Dpkg::Deps::Multiple);
  875.  
  876. sub output {
  877.     my ($self, $fh) = @_;
  878.     my $res = join(", ", map { $_->output() } grep { not $_->is_empty() } $self->get_deps());
  879.     if (defined($fh)) {
  880.     print $fh $res;
  881.     }
  882.     return $res;
  883. }
  884.  
  885. sub implies {
  886.     my ($self, $o) = @_;
  887.     # If any individual member can imply $o or NOT $o, we're fine
  888.     foreach my $dep ($self->get_deps()) {
  889.     my $implication = $dep->implies($o);
  890.     return 1 if defined($implication) && $implication == 1;
  891.     return 0 if defined($implication) && $implication == 0;
  892.     }
  893.     # If o is an AND, we might have an implication, if we find an
  894.     # implication within us for each predicate in o
  895.     if ($o->isa('Dpkg::Deps::AND')) {
  896.     my $subset = 1;
  897.     foreach my $odep ($o->get_deps()) {
  898.         my $found = 0;
  899.         foreach my $dep ($self->get_deps()) {
  900.         $found = 1 if $dep->implies($odep);
  901.         }
  902.         $subset = 0 if not $found;
  903.     }
  904.     return 1 if $subset;
  905.     }
  906.     return undef;
  907. }
  908.  
  909. sub get_evaluation {
  910.     my ($self, $facts) = @_;
  911.     # Return 1 only if all members evaluates to true
  912.     # Return 0 if at least one member evaluates to false
  913.     # Return undef otherwise
  914.     my $result = 1;
  915.     foreach my $dep ($self->get_deps()) {
  916.     my $eval = $dep->get_evaluation($facts);
  917.     if (not defined $eval) {
  918.         $result = undef;
  919.     } elsif ($eval == 0) {
  920.         $result = 0;
  921.         last;
  922.     } elsif ($eval == 1) {
  923.         # Still possible
  924.     }
  925.     }
  926.     return $result;
  927. }
  928.  
  929. sub simplify_deps {
  930.     my ($self, $facts, @knowndeps) = @_;
  931.     my @new;
  932.  
  933. WHILELOOP:
  934.     while (@{$self->{list}}) {
  935.     my $dep = shift @{$self->{list}};
  936.     my $eval = $dep->get_evaluation($facts);
  937.     next if defined($eval) and $eval == 1;
  938.     foreach my $odep (@knowndeps, @new) {
  939.         next WHILELOOP if $odep->implies($dep);
  940.     }
  941.         # When a dependency is implied by another dependency that
  942.         # follows, then invert them
  943.         # "a | b, c, a"  becomes "a, c" and not "c, a"
  944.         my $i = 0;
  945.     foreach my $odep (@{$self->{list}}) {
  946.             if (defined $odep and $odep->implies($dep)) {
  947.                 splice @{$self->{list}}, $i, 1;
  948.                 unshift @{$self->{list}}, $odep;
  949.                 next WHILELOOP;
  950.             }
  951.             $i++;
  952.     }
  953.     push @new, $dep;
  954.     }
  955.     $self->{list} = [ @new ];
  956. }
  957.  
  958.  
  959. package Dpkg::Deps::OR;
  960.  
  961. =head2 Dpkg::Deps::OR
  962.  
  963. This object represents a list of dependencies of which only one must be met
  964. for the dependency to be true.
  965.  
  966. =over 4
  967.  
  968. =item $or->output([$fh])
  969.  
  970. The output method uses " | " to join the list of sub-dependencies.
  971.  
  972. =back
  973.  
  974. =cut
  975.  
  976. use strict;
  977. use warnings;
  978.  
  979. use base qw(Dpkg::Deps::Multiple);
  980.  
  981. sub output {
  982.     my ($self, $fh) = @_;
  983.     my $res = join(" | ", map { $_->output() } grep { not $_->is_empty() } $self->get_deps());
  984.     if (defined($fh)) {
  985.     print $fh $res;
  986.     }
  987.     return $res;
  988. }
  989.  
  990. sub implies {
  991.     my ($self, $o) = @_;
  992.  
  993.     # Special case for AND with a single member, replace it by its member
  994.     if ($o->isa('Dpkg::Deps::AND')) {
  995.     my @subdeps = $o->get_deps();
  996.     if (scalar(@subdeps) == 1) {
  997.         $o = $subdeps[0];
  998.     }
  999.     }
  1000.  
  1001.     # In general, an OR dependency can't imply anything except if each
  1002.     # of its member implies a member in the other OR dependency
  1003.     if ($o->isa('Dpkg::Deps::OR')) {
  1004.     my $subset = 1;
  1005.     foreach my $dep ($self->get_deps()) {
  1006.         my $found = 0;
  1007.         foreach my $odep ($o->get_deps()) {
  1008.         $found = 1 if $dep->implies($odep);
  1009.         }
  1010.         $subset = 0 if not $found;
  1011.     }
  1012.     return 1 if $subset;
  1013.     }
  1014.     return undef;
  1015. }
  1016.  
  1017. sub get_evaluation {
  1018.     my ($self, $facts) = @_;
  1019.     # Returns false if all members evaluates to 0
  1020.     # Returns true if at least one member evaluates to true
  1021.     # Returns undef otherwise
  1022.     my $result = 0;
  1023.     foreach my $dep ($self->get_deps()) {
  1024.     my $eval = $dep->get_evaluation($facts);
  1025.     if (not defined $eval) {
  1026.         $result = undef;
  1027.     } elsif ($eval == 1) {
  1028.         $result = 1;
  1029.         last;
  1030.     } elsif ($eval == 0) {
  1031.         # Still possible to have a false evaluation
  1032.     }
  1033.     }
  1034.     return $result;
  1035. }
  1036.  
  1037. sub simplify_deps {
  1038.     my ($self, $facts) = @_;
  1039.     my @new;
  1040.  
  1041. WHILELOOP:
  1042.     while (@{$self->{list}}) {
  1043.     my $dep = shift @{$self->{list}};
  1044.     my $eval = $dep->get_evaluation($facts);
  1045.     if (defined($eval) and $eval == 1) {
  1046.         $self->{list} = [];
  1047.         return;
  1048.     }
  1049.     foreach my $odep (@new, @{$self->{list}}) {
  1050.         next WHILELOOP if $odep->implies($dep);
  1051.     }
  1052.     push @new, $dep;
  1053.     }
  1054.     $self->{list} = [ @new ];
  1055. }
  1056.  
  1057. package Dpkg::Deps::Union;
  1058.  
  1059. =head2 Dpkg::Deps::Union
  1060.  
  1061. This object represents a list of relationships.
  1062.  
  1063. =over 4
  1064.  
  1065. =item $union->output([$fh])
  1066.  
  1067. The output method uses ", " to join the list of relationships.
  1068.  
  1069. =item $union->implies($other_dep)
  1070.  
  1071. =item $union->get_evaluation($other_dep)
  1072.  
  1073. Those methods are not meaningful for this object and always return undef.
  1074.  
  1075. =item $union->simplify_deps($facts)
  1076.  
  1077. The simplication is done to generate an union of all the relationships.
  1078. It uses $simple_dep->merge_union($other_dep) to get the its job done.
  1079.  
  1080. =back
  1081.  
  1082. =cut
  1083.  
  1084. use strict;
  1085. use warnings;
  1086.  
  1087. use base qw(Dpkg::Deps::Multiple);
  1088.  
  1089. sub output {
  1090.     my ($self, $fh) = @_;
  1091.     my $res = join(", ", map { $_->output() } grep { not $_->is_empty() } $self->get_deps());
  1092.     if (defined($fh)) {
  1093.     print $fh $res;
  1094.     }
  1095.     return $res;
  1096. }
  1097.  
  1098. sub implies {
  1099.     # Implication test are not useful on Union
  1100.     return undef;
  1101. }
  1102.  
  1103. sub get_evaluation {
  1104.     # Evaluation are not useful on Union
  1105.     return undef;
  1106. }
  1107.  
  1108. sub simplify_deps {
  1109.     my ($self, $facts) = @_;
  1110.     my @new;
  1111.  
  1112. WHILELOOP:
  1113.     while (@{$self->{list}}) {
  1114.     my $dep = shift @{$self->{list}};
  1115.     foreach my $odep (@new) {
  1116.         next WHILELOOP if $dep->merge_union($odep);
  1117.     }
  1118.     push @new, $dep;
  1119.     }
  1120.     $self->{list} = [ @new ];
  1121. }
  1122.  
  1123. package Dpkg::Deps::KnownFacts;
  1124.  
  1125. =head2 Dpkg::Deps::KnowFacts
  1126.  
  1127. This object represents a list of installed packages and a list of virtual
  1128. packages provided (by the set of installed packages).
  1129.  
  1130. =over 4
  1131.  
  1132. =item my $facts = Dpkg::Deps::KnownFacts->new();
  1133.  
  1134. Create a new object.
  1135.  
  1136. =cut
  1137.  
  1138. use strict;
  1139. use warnings;
  1140.  
  1141. sub new {
  1142.     my $this = shift;
  1143.     my $class = ref($this) || $this;
  1144.     my $self = { 'pkg' => {}, 'virtualpkg' => {} };
  1145.     bless $self, $class;
  1146.     return $self;
  1147. }
  1148.  
  1149. =item $facts->add_installed_package($package, $version)
  1150.  
  1151. Record that the given version of the package is installed. If $version is
  1152. undefined we know that the package is installed but we don't know which
  1153. version it is.
  1154.  
  1155. =cut
  1156.  
  1157. sub add_installed_package {
  1158.     my ($self, $pkg, $ver) = @_;
  1159.     $self->{pkg}{$pkg} = $ver;
  1160. }
  1161.  
  1162. =item $facts->add_provided_package($virtual, $relation, $version, $by)
  1163.  
  1164. Record that the "$by" package provides the $virtual package. $relation
  1165. and $version correspond to the associated relation given in the Provides
  1166. field. This might be used in the future for versioned provides.
  1167.  
  1168. =cut
  1169.  
  1170. sub add_provided_package {
  1171.     my ($self, $pkg, $rel, $ver, $by) = @_;
  1172.     if (not exists $self->{virtualpkg}{$pkg}) {
  1173.     $self->{virtualpkg}{$pkg} = [];
  1174.     }
  1175.     push @{$self->{virtualpkg}{$pkg}}, [ $by, $rel, $ver ];
  1176. }
  1177.  
  1178. =item my ($check, $param) = $facts->check_package($package)
  1179.  
  1180. $check is one when the package is found. For a real package, $param
  1181. contains the version. For a virtual package, $param contains an array
  1182. reference containing the list of packages that provide it (each package is
  1183. listed as [ $provider, $relation, $version ]).
  1184.  
  1185. =back
  1186.  
  1187. =cut
  1188.  
  1189. sub check_package {
  1190.     my ($self, $pkg) = @_;
  1191.     if (exists $self->{pkg}{$pkg}) {
  1192.     return (1, $self->{pkg}{$pkg});
  1193.     }
  1194.     if (exists $self->{virtualpkg}{$pkg}) {
  1195.     return (1, $self->{virtualpkg}{$pkg});
  1196.     }
  1197.     return (0, undef);
  1198. }
  1199.  
  1200. 1;
  1201.